home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 22 / CU Amiga Magazine's Super CD-ROM 22 (1998)(EMAP Images)(GB)[!][issue 1998-05].iso / PowerPC / Programming / PPCTinyProlog / prolog.c < prev    next >
C/C++ Source or Header  |  1988-05-26  |  34KB  |  1,388 lines
  1. #include <stdio.h>
  2. #include "prolog.h"
  3. node *copylist();
  4. boolean unify();                    
  5. main()
  6.     {
  7.     initialize() ;
  8.     compile(stdin) ;
  9.     }
  10.  
  11. /* Copyright 1986 - MicroExpert Systems
  12.                     Box 430 R.D. 2
  13.                     Nassau, NY 12123       */
  14.  
  15. /* Revisions - 1.1  Nov. 1986   - Edinburgh list syntax added */
  16. /* 11-9-87 converted to lattice c by Dennis J. Darland  [73300,270] */
  17. /* VTPROLOG implements the data base searching and pattern matching of
  18.    PROLOG. It is described in "PROLOG from the Bottom Up" in issues
  19.    1 and 2 of AI Expert.
  20.  
  21.     Tested on AMIGA lattice c.
  22.     Requires -cu option for unsigned char's.
  23.         
  24.    We would be pleased to hear your comments, good or bad, or any applications
  25.    and modifications of the program. Contact us at:
  26.  
  27.      AI Expert
  28.      CL Publications Inc.
  29.      650 Fifth St.
  30.      Suite 311
  31.      San Francisco, CA 94107
  32.  
  33.    or on the AI Expert BBS. Our id is BillandBev Thompson ,[76703,4324].
  34.    You can also contact us on BIX, our id is bbt.
  35.  
  36.    Bill and Bev Thompson    */
  37.  
  38. /* ----------------------------------------------------------------------
  39.         Utility Routines
  40.    ---------------------------------------------------------------------- */
  41. int  indelim(ch)
  42. register unsigned char ch;
  43.     {
  44.     return (ch == ' '
  45.         || ch == ')'
  46.         || ch == '('
  47.         || ch == ','
  48.         || ch == '['
  49.         || ch == ']'
  50.         || ch == tab
  51.         || ch == quote_char
  52.         || ch == ':'
  53.         || ch == '@'
  54.         || ch == '.'
  55.         || ch == 0xff
  56.         || ch == '?'
  57.         || ch == '|');
  58.     }        
  59.  
  60. int isconsole(f)
  61. register FILE *f;
  62. /* return true if f is open on the system console
  63.    for details of fibs and fibptrs see the Turbo Pascal ver 3.0 reference
  64.    manual chapter 20. This should work under CP/M-86 or 80, but we haven't
  65.    tried it. */
  66.     {
  67.     return(f == stdin);
  68.     } /* isconsole */
  69.  
  70. stripleadingblanks(s)
  71. register char *s;
  72.     {
  73.     if (strlen(s) > 0)
  74.         {        
  75.         if ((s[0] == ' ') || (s[0] == tab))
  76.             {
  77.             delete(s,0,1) ;
  78.             stripleadingblanks(s) ;
  79.             }
  80.         }                
  81.     } /* stripleadingblanks */
  82.             
  83. striptrailingblanks(s)
  84. register char *s;
  85.     {
  86.     if (strlen(s) > 0)
  87.         {                    
  88.         if ((s[strlen(s)-1] == ' ') || (s[strlen(s)-1] == tab))
  89.             {
  90.             delete(s,strlen(s)-1,1) ;
  91.             striptrailingblanks(s) ;
  92.             }
  93.         }
  94.     } /* striptrailingblanks */
  95.                         
  96. int isnumber(s)
  97. register char *s;
  98. /* checks to see if s contains a legitimate numerical string.
  99. It ignores leading and trailing blanks */
  100.     {
  101.     int num;
  102.     register int code;
  103.                     
  104.     striptrailingblanks(s) ;
  105.     stripleadingblanks(s) ;
  106.     if (strlen(s) > 0)
  107.         code =stcd_i(s,&num);
  108.     else 
  109.         code = -1 ;
  110.     return(code >0) ;
  111.     } /* isnumber */
  112.  
  113.                                                 
  114. /*
  115. double cardinal(i)
  116. register int i;
  117.     {
  118.     double r;
  119.     r = i ;
  120.     return(r);
  121.     }*/ /* cardinal */
  122.                         
  123. node *head(list) 
  124. register node *list;
  125. /* returns a pointer to the first item in the list.
  126. If the list is empty, it returns NULL.  */
  127.     {
  128.     if (list == NULL)
  129.         return(NULL);
  130.     else 
  131.         return(list->node_union.cons_node.head_ptr) ;
  132.     } /* head */
  133.                         
  134. node *tail(list)
  135. register node *list;
  136. /* returns a pointer to a list starting at the second item in the list.
  137. Note - tail( (a b c) ) points to the list (b c), but
  138. tail( ((a b) c d) ) points to the list (c d) .  */
  139.     {
  140.     if (list == NULL)
  141.         return( NULL);
  142.     else
  143.         {
  144.         switch (list->tag)
  145.             {
  146.         case consnode : return(list->node_union.cons_node.tail_ptr) ;
  147.                         break;
  148.         default : return(NULL);
  149.                 break;
  150.             }
  151.         }
  152.     } /* tail */
  153.                     
  154. char *stringval(list)
  155. register node *list;
  156. /* returns the string pointed to by list. If list points to a number
  157. node, it returns a string representing that number */
  158.     {
  159.  
  160.     if (list == NULL)
  161.         {
  162.         return(NULL);
  163.         }
  164.     else if ((list->tag ==constant)
  165.     || (list->tag ==variable)
  166.     || (list->tag ==func))
  167.         {
  168.         return(list->node_union.string_data);
  169.         }
  170.     else 
  171.         {
  172.         return(NULL);
  173.         }
  174.     } /* stringval */
  175.                     
  176. enum node_type tagvalue(list)
  177. register node *list;
  178. /* returns the value of the tag for a node.     */
  179.     {
  180.         return(list->tag) ;
  181.     } /* tagvalue */
  182.                     
  183. printlist(list)
  184. register node *list;
  185. /* recursively traverses the list and prints its elements. This is
  186. not a pretty printer, so the lists may look a bit messy.  */
  187.     {
  188.     register node *p;
  189.     if (list != NULL)
  190.         {
  191.         switch (list->tag)
  192.             {
  193.         case constant:
  194.         case func:
  195.         case variable  :
  196.              printf("%s ",stringval(list));
  197.              break;
  198.         case consnode : 
  199.                 printf("(") ;
  200.                 p = list ;
  201.                 while (p != NULL)
  202.                     {
  203.                     if (tagvalue(p) == consnode)
  204.                         printlist(head(p));
  205.                     else 
  206.                         printlist(p) ;
  207.                     p = tail(p) ;
  208.                     }
  209.                 printf(") ") ;
  210.             break;
  211.             }
  212.         }
  213.     } /* printlist */
  214.                         
  215. node *allocstr(typ,s)
  216. enum node_type typ;
  217. register char *s;
  218. /* Allocate storage for a string. */
  219.     {
  220.     register node *pt;
  221.             
  222.     pt = (node *)malloc(sizeof(node)) ;
  223.     add_chain(pt);
  224.     pt->tag = typ   ;
  225.     strcpy(pt->node_union.string_data, s) ;
  226.     return(pt );
  227.     } /* allocstr */
  228.                                             
  229. node *cons(newnode,list)
  230. register node *newnode,*list;
  231. /* Construct a list. This routine allocates storage for a new cons node.
  232. newnode points to the new head of the list. The tail pointer of the
  233. new node points to list. This routine adds the new cons node to the
  234. beginning of the list and returns a pointer to it. The list described
  235. in the comments at the beginning of the program could be constructed
  236. as cons(allocstr('A'),cons(allocstr('B'),cons(allocstr('C'),NULL))). */
  237.     {
  238.     register node *p;
  239.     p = (node *) malloc(sizeof(node)) ;
  240.     add_chain(p);
  241.     p->tag = consnode ;
  242.     p->node_union.cons_node.head_ptr = newnode ;
  243.     p->node_union.cons_node.tail_ptr = list ;
  244.     return( p) ;
  245.     } /* cons */
  246.                                             
  247. node *appendlist(list1,list2)
  248. register node *list1,*list2;
  249. /* Append list2 to list1. This routine returns a pointer to the
  250. combined list. Appending is done by consing each item on the first
  251. list to the second list. This routine is one of the major sources of
  252. garbage so if garbage collection becomes a problem, you may want to
  253. rewrite it. */
  254.     {
  255.     if (list1 == NULL)
  256.         return(list2);
  257.     else 
  258.         return(cons(head(list1),appendlist(tail(list1),list2))) ;
  259.     } /* appendlist */
  260.                                             
  261. counter listlength(list)
  262. register node *list;
  263. /* returns the length of a list.
  264. Note - both (A B C) and ( (A B) C D) have length 3.   */
  265.     {
  266.     if (list == NULL)
  267.         return(0);
  268.     else 
  269.         return(1 + listlength(list->node_union.cons_node.tail_ptr)) ;
  270.     } /* listlength */
  271.                                             
  272. collectgarbage()
  273.     {
  274.     printf("*") ;
  275.    unmarkmem() ;
  276.    mark(saved_list) ;
  277.    freemem() ;
  278.     }
  279. /* end collectgarbage scope */                                            
  280. testmemory() 
  281.     {
  282.     if (chain_cnt > MAX_ALLOC)
  283.         collectgarbage() ;
  284.     }     /* testmemory */
  285.                                                                                 
  286. wait()
  287. /* Just like it says. It waits for the user to press a key before
  288. continuing. */
  289.     {
  290.     register char ch;
  291.     printf("\n") ;
  292.     printf("\n") ;
  293.     printf("Press any key to continue.\n ") ;
  294.     ch = getchar();
  295.     printf("\n") ;
  296.     } /* wait */
  297.                                                                                 
  298. /* ------------------------------------------------------------------------
  299. End of utility routines
  300. ------------------------------------------------------------------------ */
  301.  
  302. readfromfile(f)
  303. register FILE *f;
  304. /* Read a line from file f and store it in the global variable line.
  305. It ignores blank lines and when the end of file is reached an
  306. eofmark is returned. */
  307.     {
  308.     register unsigned char *cp;
  309.     register int  test;
  310.     for (cp=line; cp<&line[131]; cp++)
  311.         {
  312.         test = fgetc(f);
  313.         if (test == EOF)
  314.             {
  315.             *cp++ = 0xff;
  316.             *cp = 0;
  317.             break;
  318.             }
  319.         else
  320.             *cp = test;
  321.         if (*cp == '\n')
  322.             {
  323.             *cp = '\0';
  324.             break;
  325.             }
  326.         }
  327.     } /* readfromfile */
  328. /* end readfromfile scope */
  329. gettoken(tline,token)
  330. register char *tline;
  331. register char *token;
  332. /* Extract a token from tline. Comments are ignored. A token is
  333. a string surrounded by delimiters or an end of line. Tokens may
  334. contain embedded spaces if they are surrounded by quote marks */
  335.     {
  336.     stripleadingblanks(tline) ;
  337.     if (strlen(tline) > 0)
  338.         {
  339.         if (strncmp(tline,"/*",2)== 0)
  340.             {
  341.             comment(tline);
  342.             }
  343.         else if ((strncmp(tline,":-",2) == 0) || (strncmp(tline,"?-",2) == 0))
  344.             {
  345.             strncpy(token,tline,2) ;
  346.             token[2] = 0;
  347.             delete(tline,0,2) ;
  348.             }
  349.         else if (tline[0] == quote_char)
  350.             getquote(tline);
  351.         else if (indelim(tline[0]))
  352.             {
  353.             token[0] = tline[0] ;
  354.             token[1] = 0;
  355.             delete(tline,0,1) ;
  356.             }
  357.         else getword(tline) ;
  358.         }
  359.     else token[0] = '\0' ;
  360.     } /* gettoken */
  361.                             
  362. getword(tline)
  363. register char *tline;
  364.     {
  365.     register boolean done;
  366.     register int cn;
  367.     register int len;
  368.                 
  369.     cn = 0 ;
  370.     len = strlen(tline) ;
  371.     done = false ;
  372.     while (! done)
  373.         {
  374.         if (cn > len)
  375.             done = true;
  376.         else if (indelim(tline[cn]))
  377.             done = true;
  378.         else 
  379.             cn++;
  380.         }
  381.     strncpy(token,tline,cn) ;
  382.     token[cn] = 0;
  383.     delete(tline,0,cn) ;
  384.     } /* getword */
  385. int pos(p1,p2)
  386. register char *p1,*p2;
  387.     {
  388.     register int len;
  389.     char *p3;
  390.     len = stcpm(p2,p1,&p3);
  391.     if (len >0)
  392.         return((int)p3-(int)p2);
  393.     else
  394.         return(-1);
  395.     }
  396. delete(p1,pos,n)
  397. register char *p1;
  398. register int pos,n;
  399.     {
  400.     int i;
  401.     for (i=pos;;i++)
  402.         {
  403.         p1[i]=p1[i+n];
  404.         if (p1[i] == 0)
  405.             break;
  406.         }
  407.     }
  408. comment(tline)
  409. register char *tline;
  410.     {
  411.     if (pos("*/",tline) >=0)
  412.         {
  413.         delete(tline,0,pos("*/",tline)+1) ;
  414.         gettoken(line,token) ;
  415.         }
  416.     else
  417.         {
  418.         tline[0] = '\0' ;
  419.         token[0] = '\0' ;
  420.         in_comment = true ;
  421.         }
  422.     } /* comment */
  423. getquote(tline)
  424. register char *tline;
  425.     {
  426.     register int i;
  427.     
  428.     delete(tline,0,1) ;
  429.     if (pos(quote_char,tline) >= 0)
  430.         {
  431.         token[0] = quote_char;
  432.         for (i=1;i<=pos("'",tline);i++)
  433.             token[i]=tline[i];
  434.         token[i]=0;    
  435.         delete(tline,0,pos(quote_char,tline)) ;
  436.         }
  437.     else
  438.         {
  439.         strcpy(token,tline) ;
  440.         tline[0] = '\0' ;
  441.         }
  442.     } /* getquote */
  443.                                                                                                                                 
  444. /* end scope gettoken */                                                                                                                                                                                                    
  445. scan(f,token)
  446. register FILE *f;
  447. register char *token;
  448. /* Scan repeatedly calls gettoken to retreive tokens. When the
  449. end of a line has been reached, readfromfile is called to
  450. get a new line. */
  451.     {
  452.     if (strlen(line) > 0)
  453.                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                     
  454.         {
  455.         gettoken(line,token) ;
  456.         }
  457.     else
  458.         {
  459.         readfromfile(f) ;
  460.         scan(f,token) ;
  461.         }
  462.     } /* scan */
  463.                                                                                                                                                                                                                                                                                 
  464. compile(source)
  465. register FILE *source; 
  466. /* The recursive descent compiler. It reads tokens until the token
  467. 'EXIT' is found. If the token is '?-', a query is performed, a '@' token
  468. is the command to read a new file and source statements are read form that
  469. file, otherwise the token is assumed to be part of a sentence and the rest
  470. of the sentence is parsed. */
  471.     {
  472.     scan(source,token) ;
  473.     while (token[0] != 0xff)
  474.         {
  475.         error_flag = false ;
  476.         if (strncmp(token,"?-",2)== 0)
  477.             {
  478.             scan(source,token) ;
  479.             query(source) ;
  480.             }
  481.         else if (strcmp(token,"@")== 0)
  482.             {
  483.             scan(source,token) ;
  484.             readnewfile(source) ;
  485.             }
  486.         else if (strncmp(token,"EXIT",4)==0)
  487.             doexit(source);
  488.         else if (token[0] == 0xff)
  489.             break;
  490.         else 
  491.             rule(source) ;
  492.         scan(source,token) ;
  493.         }
  494.     } /* compile */
  495.                         
  496. error(errormsg,source)
  497. register char *errormsg;
  498. register FILE *source;
  499. /* Signal an error. Prints saved_line to show where the error is located.
  500. saved_line contains the current line being parsed. it is required,
  501. because gettoken chews up line as it reads tokens. */
  502.     {
  503.     error_flag = true ;
  504.     printf("\n") ;
  505.     printf(errormsg) ;
  506.     printf("\n") ;
  507. /*    printf(saved_line) ; */
  508. /*    writeln(" : strlen(saved_line) - strlen(line) - 1,^") ; ;*/
  509.     if (isconsole(source))
  510.         {
  511.         token[0] = '.' ;
  512.         token[1] = 0;
  513.         line[0] = '\0' ;
  514.         }
  515.     else runout(source) ;
  516.     wait() ;
  517.     } /* error */
  518. runout(source)
  519. register FILE *source;
  520.     {
  521.     while ((strcmp(token,".") != 0) && (token[0] != 0xff))
  522.         scan(source,token) ;
  523.     } /* runout */
  524. /* end scope error*/
  525. goal(lptr,source)
  526. register node **lptr;
  527. register FILE *source;
  528. /* Read a goal. The new goal is appended to lptr. Each goal is appended
  529. to lptr as a list. Thus, the sentence 'likes(john,X) :- likes(X,wine) .'
  530. becomes the list ( (likes john X) (likes X wine) ) */
  531.     {
  532.     char goaltoken[80];
  533.     if ((token[0] >='a' && token[0] <= 'z') || token[0] == quote_char)
  534.         {
  535.         if (token[0] == quote_char)
  536.             {
  537.             *lptr = appendlist(*lptr,cons(cons(allocstr(constant,
  538.             &token[1]),NULL),NULL)) ;
  539.             scan(source,token) ;
  540.             }
  541.         else
  542.             {
  543.             strcpy(goaltoken,token) ;
  544.             scan(source,token) ;
  545.             if (token[0] == '(')
  546.                 functor(lptr,goaltoken,source);
  547.             else 
  548.                 *lptr = appendlist(*lptr,
  549.                 cons(cons(allocstr(constant,goaltoken),NULL),NULL)) ;
  550.             }
  551.         }
  552.     else 
  553.         error("A goal must begin with 'a .. z' or be a quoted string.",source) ;
  554.     } /* goal */
  555. functor(fptr, functoken,source)
  556. register node **fptr;
  557. register char    *functoken;
  558. register FILE *source;
  559. /* The current goal is a functor. This routine allocates a node
  560. to store the functor and  processes the components of the
  561. functor. On exit, fptr points to the list containing the functor
  562. and its components. functoken contains the functor name. */
  563.     {
  564.     node *cptr;
  565.     cptr = cons(allocstr(func,functoken),NULL) ;
  566.     scan(source,token) ;
  567.     components(&cptr,source) ;
  568.     if (token[0] == ')')
  569.         {
  570.         *fptr = appendlist(*fptr,cons(cptr,NULL)) ;
  571.         scan(source,token) ;
  572.         }
  573.     else error("Missing ')'.",source) ;
  574.     } /* functor */
  575. components(cmptr,source)
  576. register node * *cmptr;
  577. register FILE *source;
  578. /* Process the components of the functor. The components are terms
  579. seperated by commas. On exit, cmptr points to the list of
  580. components. */
  581.     {
  582.     term(cmptr,source) ;
  583.     if (token[0] == ',')
  584.         {
  585.         scan(source,token) ;
  586.         components(cmptr,source) ;
  587.         }
  588.     } /* components */
  589.                         
  590. term(tptr,source)
  591. register node * *tptr ;
  592. register FILE *source;
  593. /* Process a single term. The new term is appended to tptr. */
  594.     {
  595.     char   ttoken[80];
  596.     if (token[0] >= 'A' && token[0] <= 'Z')
  597.     varbl(tptr,source);
  598.     else if (token[0] == quote_char)
  599.     quotedstr(tptr,source);
  600.     else if (isnumber(token))
  601.     number(tptr,source);
  602.     else if (token[0] == '[')
  603.         list(tptr,source);
  604.     else if (token[0] >= 'a' && token[0] <= 'z')
  605.         {
  606.         strcpy(ttoken, token) ;
  607.         scan(source,token) ;
  608.         if (token[0] == '(')
  609.         functor(tptr,ttoken,source);
  610.         else 
  611.         *tptr = appendlist(*tptr,cons(allocstr(constant,ttoken),NULL)) ;
  612.         }
  613.     else 
  614.     error("Illegal Symbol.",source) ;
  615.     } /* term */
  616. quotedstr(qptr,source)
  617. register node * *qptr;
  618. register FILE *source;
  619. /* Process a quote */
  620.     {
  621.     *qptr = appendlist(*qptr,cons(allocstr(constant,&token[1]),NULL)) ;
  622.     scan(source,token) ;
  623.     } /* quotedstr */
  624. varbl(vptr,source)
  625. register node * *vptr ;
  626. register FILE *source;
  627. /* The current token is a varaible, allocate a node and return
  628. a pointer to it. */
  629.     {
  630.     *vptr = appendlist(*vptr,cons(allocstr(variable,token),NULL)) ;
  631.     scan(source,token) ;
  632.     } /* varbl */
  633. number(nptr,source)
  634. register node * *nptr;
  635. register FILE *source;
  636. /* Numbers are treated as string constants. This isn't particularly
  637. efficent, but it is easy. */
  638.     {
  639.     *nptr = appendlist(*nptr,cons(allocstr(constant,token),NULL)) ;
  640.     scan(source,token) ;
  641.     } /* number */
  642. list(lptr,source)
  643. register node * *lptr ;
  644. register FILE *source;
  645. /* A list may either be empty, [], or it may be an group of
  646. elements surrounded by brackets. On return, lptr has the
  647. list structure appended to it. */
  648.     {
  649.     node *elemlist;
  650.         
  651.     scan(source,token) ;
  652.     if (token[0] == ']')
  653.         {
  654.         *lptr = appendlist(*lptr,cons(NULL,NULL)) ;
  655.         scan(source,token) ;
  656.         }
  657.     else
  658.         {
  659.         elemlist = NULL ;
  660.         elementlist(&elemlist,source) ;
  661.         if (token[0] == ']')
  662.             {
  663.             scan(source,token) ;
  664.             *lptr = appendlist(*lptr,cons(elemlist,NULL)) ;
  665.             }
  666.         else error("Missing ']'.",source) ;
  667.         }
  668.     } /* list */
  669. elementlist(elist,source)
  670. register node * *elist ;
  671. register FILE *source;
  672. /* The element list is a group of terms separated by commas */
  673.     {
  674.     node *elist2;
  675.         
  676.     term(elist,source) ;
  677.     if (token[0] == ',')
  678.         {
  679.         scan(source,token) ;
  680.         elementlist(elist,source) ;
  681.         }
  682.     else if (token[0] == '|')
  683.         {
  684.         elist2 = NULL ;
  685.         scan(source,token) ;
  686.         term(&elist2,source) ;
  687.         *elist = appendlist(*elist,head(elist2)) ;
  688.         }
  689.     } /* elementlist */
  690. /* end scope list */
  691. /* end scope term */
  692. /* end scope components */
  693. /* end scope functor */    
  694. /* end scope goal */    
  695. taillist(tptr,source)
  696. register node * *tptr ;
  697. register FILE *source;
  698. /* Process the tail of a rule. Since the a query is syntactically identical
  699. to the tail of a rule, this routine is used to compile queries.
  700. On exit, tptr points to the list containing the tail. */
  701.     {
  702.     goal(tptr,source) ;
  703.     if (token[0] == ',')
  704.         {
  705.         scan(source,token) ;
  706.         taillist(tptr,source) ;
  707.         }
  708.     } /* taillist */
  709. rule(source)
  710. register FILE *source;
  711. /* Procees a rule, actually any sentence. If no error occurs the
  712. new sentence is appended to the data base. */
  713.     {
  714.     node * rptr;
  715.         
  716.     saved_list = cons(data_base,NULL) ;
  717.     testmemory() ; 
  718.     rptr = NULL ;
  719.     headlist(&rptr,source) ;
  720.     if (strcmp(token,":-")==0)
  721.         {
  722.         scan(source,token) ;
  723.         taillist(&rptr,source) ;
  724.         }
  725.     if (token[0] != '.')
  726.         error("'.' expected.",source) ;
  727.     if (! error_flag)
  728.     data_base = appendlist(data_base,cons(rptr,NULL)) ;
  729.     } /* rule */
  730. headlist(hptr,source)
  731. register node * *hptr ;
  732. register FILE *source;
  733.     {
  734.     goal(hptr,source) ;
  735.     } /* head */
  736. /* end scope rule */
  737. query(source)
  738. register FILE *source;
  739. /* Process a query. Compile the query, and  call solve to search the
  740. data base. qptr points to the compiled query and solved is a boolean
  741. indicating whether the query was successfully solved. */
  742.     {
  743.     node *qptr;
  744.     boolean solved;
  745.         
  746.     qptr = NULL ;
  747.     taillist(&qptr,source) ;
  748.     if (token[0] != '.')
  749.     error("''.'' expected.",source);
  750.     else if (! error_flag)
  751.         {
  752.         solved = false ;
  753.         saved_list = cons(data_base,NULL) ;
  754.         solve(qptr,NULL,0,&solved) ;
  755.         if (! solved)
  756.             printf("No\n") ;
  757.         }
  758.     } /* query */
  759. solve(list,env,level,solved)
  760. register node *list;
  761. node *env;
  762. register counter level;
  763. register boolean *solved;
  764. /* This is where all the hard work is done. This routine follows the
  765. steps outlined in the article. list is the query to be soved, env is
  766. the current environment and level is the recursion level. level can
  767. only get to 32767, but you'll run out of stack space long before you
  768. get that far.
  769. solve saves list and env on the saved list so that they won't be
  770. destroyed by garbage collection. The data base is always on the
  771. saved list. At the end of solve, list and env are removed from
  772. saved_list. */
  773.     {
  774.     node *newenv;
  775.     register node *p;
  776.     saved_list = cons(list,cons(env,saved_list)) ;
  777.     if (list == NULL )
  778.         {
  779.         checkcontinue(solved,&env,level);
  780.         } 
  781.     else
  782.         {
  783.         p = data_base;
  784.         while (p && !(*solved))
  785.             {
  786.             testmemory() ; 
  787.             if (unify(copylist(head(head(p)),level),head(list),env,&newenv))
  788.                 {
  789.                 solve(appendlist(copylist(tail(head(p)),level),tail(list)),
  790.                 newenv,level + 1,solved) ;
  791.                 }
  792.             p = tail(p);
  793.             }
  794.         }
  795.     saved_list = tail(tail(saved_list)) ;
  796.     } /* solve */
  797. node *lookup(varstr, environ)
  798. register char *varstr;
  799. register node * environ;
  800. /* Search the environment list pointed to by environ for the variable,
  801. varstr. If found return a pointer to varstr's binding, otherwise
  802. return NULL */
  803.     {
  804.     register boolean found;
  805.     register node * p;
  806.         
  807.     p = environ ;
  808.     found = false ;
  809.     while ((p != NULL) && (! found))
  810.         {
  811.         if (strcmp(varstr,stringval(head(head(p))))==0)
  812.             {
  813.             found = true ;
  814.             return(tail(head(p))) ;
  815.             }
  816.         else p = tail(p) ;
  817.         }
  818.     if (! found)
  819.     return( NULL) ;
  820.     } /* lookup */
  821. checkcontinue(solved,env,level)
  822. register boolean *solved;
  823. register node * *env;
  824. register int level;
  825. /* Print the bindings and see if the user is satisfied. If nothing
  826. is printed from the environment,  print 'Yes' to indicate
  827. that the query was successfully satisfied. */
  828.     {
  829.     boolean printed, listprinting;
  830.     register char ch;
  831.     printed = false ;
  832.     listprinting = false ;
  833.     printbindings(*env,&listprinting,&printed,env) ;
  834.     if (! printed && level == 0)
  835.         {
  836.         printf("\n") ;
  837.         printf("Yes\n ") ;
  838.         printf("Press 'm' for more or 'q' to quit.\n");
  839.         do
  840.             ch = getchar() ;
  841.         while (ch!= 'm' && ch != 'q');
  842.         *solved = (ch == 'q') ;
  843.         }
  844.     else if (printed)
  845.         {
  846.         printf("\n") ;
  847.         printf("Press 'm' for more or 'q' to quit.\n");
  848.         do
  849.             ch = getchar() ;
  850.         while (ch!= 'm' && ch != 'q');
  851.         *solved = (ch == 'q') ;
  852.         }
  853.     } /* checkcontinue */
  854. printbindings(list,listprinting,printed,env)
  855. register node * list ;
  856. register boolean *listprinting;
  857. register boolean *printed;
  858. register node * *env;
  859. /* Print the bindings for level 0 variables only, intermediate variables
  860. aren't of interest. The routine recursivley searches for the
  861. end of the environments list and  prints the binding. This
  862. is so that variables bound first are printed first. */
  863.     {
  864.     if (list != NULL)
  865.         {
  866.         printbindings(tail(list),listprinting,printed,env) ;
  867.         if (pos("#",stringval(head(head(list)))) == -1) 
  868.             {
  869.             *printed = true;
  870.             printf("\n");
  871.             printf("%s == ",stringval(head(head(list)))) ;
  872.             switch (tagvalue(tail(head(list))))
  873.                 {
  874.             case constant  : 
  875.                 printf("%s ",stringval(tail(head(list)))) ;
  876.                 break;
  877.             case variable  : 
  878.                 printvariable(stringval(tail(head(list))),listprinting,env) ;
  879.                 break;
  880.             case consnode : 
  881.                 printalist(tail(head(list)),listprinting,env) ;
  882.                 break;
  883.                 }
  884.             }
  885.         }
  886.     } /* printbindings */
  887.                         
  888. printvariable(varstr,listprinting,env)
  889. register char *varstr;
  890. register boolean *listprinting;
  891. register node * *env;
  892. /* The varaible in question was bound to another varaible, so look
  893. up that variable's binding and print it. If a match can't be found
  894. print '' to tell the user that the variable is anonymous. */
  895.     {
  896.     node *varptr;
  897.     
  898.     varptr = lookup(varstr,*env) ;
  899.     if (varptr != NULL)
  900.         {
  901.         switch (tagvalue(varptr))
  902.             {
  903.         case constant  : printf("%s ",stringval(varptr)) ;
  904.                         break;
  905.         case variable  : printvariable(stringval(varptr),env) ;
  906.                         break;
  907.         case consnode : 
  908.             if (*listprinting)
  909.                 printcomponents(varptr,listprinting,env);
  910.             else 
  911.                 printalist(varptr,listprinting,env) ;
  912.             break;
  913.             }
  914.         }
  915.     else 
  916.         printf(" ") ;
  917.     } /* printvariable */
  918. printfunc(p ,listprinting,env)
  919. register node * p ;
  920. register boolean *listprinting;
  921.     {
  922.     printf("%s",stringval(head(p))) ;
  923.     printf("(") ;
  924.     printcomponents(tail(p),listprinting,env) ;
  925.     printf(")") ;
  926.     } /* printfunc */
  927. printcomponents(p,listprinting,env)
  928. register node * p;
  929. register boolean *listprinting;
  930. register node * *env;
  931. /* Print the components of a functor. These may be variables or
  932. other functors, so call the approriate routines to print them. */
  933.     {
  934.     if (p != NULL)
  935.         {
  936.         switch (tagvalue(p))
  937.             {
  938.         case constant  : printf("%s ",stringval(p)) ;
  939.                 break;
  940.         case variable  : printvariable(stringval(p),env) ;
  941.                 break;
  942.         case consnode : 
  943.                 if (tagvalue(head(p)) == func)
  944.                     printfunc(p,listprinting,env);
  945.                 else
  946.                     {
  947.                     if (tagvalue(head(p)) == consnode)
  948.                         printalist(head(p),listprinting,env);
  949.                     else 
  950.                         printcomponents(head(p),listprinting,env) ;
  951.                     if (tail(p) != NULL)
  952.                         {
  953.                         printf(",") ;
  954.                         printcomponents(tail(p),listprinting,env) ;
  955.                         }
  956.                     }
  957.                 break;
  958.             }
  959.         }
  960.     } /* printcomponents */
  961. printalist(l,listprinting,env) 
  962. register node * l;
  963. register boolean *listprinting;
  964. register node * *env;
  965. /* The variable was bound to a functor. Print the functor and its
  966. components. */
  967.     {
  968.     if (l != NULL)
  969.         {            
  970.         if (tagvalue(head(l)) == func)
  971.             printfunc(l,listprinting,env);
  972.         else
  973.             {
  974.             *listprinting = true ;
  975.             printf("[") ;
  976.             printcomponents(l,listprinting,env) ;
  977.             printf("]") ;
  978.             }
  979.         }
  980.     } /* printalist */
  981. /* end scope printbindings */
  982. /* end scope checkcontinue */
  983. node *copylist(list , copylevel)
  984. register node * list;
  985. counter copylevel;
  986. /* Copy a list and append the copylevel (recursion level) to all
  987. variables. */
  988.     {
  989.     node     *templist;
  990.     char    levelstr[8];
  991.         
  992.     sprintf(levelstr,"#%d",copylevel);
  993.     templist = NULL ;
  994.     listcopy(list,&templist,©level,levelstr) ;
  995.     return( templist) ;
  996.     } /* copylist */
  997. listcopy(fromlist,tolist,copylevel,levelstr)
  998. register node * fromlist;
  999. register node * *tolist;
  1000. register counter *copylevel;
  1001. register char *levelstr;
  1002.     {
  1003.     if (fromlist != NULL)
  1004.         {
  1005.         char temp[132];
  1006.         switch (fromlist->tag)
  1007.             {
  1008.         case variable : 
  1009.             sprintf(temp,"%s%s",fromlist->node_union.string_data,levelstr);
  1010.             *tolist = allocstr(variable,temp) ;
  1011.             break;
  1012.         case func:
  1013.         case constant  : *tolist = fromlist ;
  1014.                 break;
  1015.         case consnode : 
  1016.                 listcopy(tail(fromlist),tolist,copylevel,levelstr) ;
  1017.                 *tolist = cons(copylist(head(fromlist),*copylevel),*tolist) ;
  1018.                 break;
  1019.             }
  1020.         }
  1021.     } /* listcopy */
  1022. /* end scope copylist */
  1023. boolean unify(list1,list2,environ,newenviron)
  1024. node *list1,*list2,*environ ;
  1025. register node **newenviron;
  1026. /* Unify two lists and return any new bindings at the front of the
  1027. environment list. Returns true if the lists could be unified. This
  1028. routine implements the unification table described in the article.
  1029. Unification is straight forward, but the details of matching the
  1030. lists get a little messy in this routine. There are better ways to
  1031. do all of this, we just haven't gotten around to trying them. If
  1032. you implement any other unification methods, we would be glad to
  1033. hear about it.
  1034. Unify checks to see if both lists are NULL, this is a successful
  1035. unification. Otherwise check what kind on node the head of list1
  1036. is and call the appropriate routine to perform the unification.
  1037. Variables are unified by looking up the binding of the variable.
  1038. If none is found, make a binding for the variable, otherwise try to
  1039. unify the binding with list2. */
  1040.     {
  1041.     boolean unifyvar;
  1042.     register boolean uv;
  1043.     node *varptr;
  1044.     if ((list1 == NULL) && (list2 == NULL))
  1045.         {
  1046.         unifyvar = true ;
  1047. /*        *newenviron = environ ; */
  1048.         }
  1049.     else if (list1 == NULL)
  1050.         {
  1051.         uv = unify(list2,list1,environ,newenviron);
  1052.         return(uv);
  1053.         }
  1054.     else
  1055.         {
  1056.         switch (tagvalue(list1))
  1057.             {
  1058.         case constant :
  1059.             unifyconstant(&list1,&list2,&varptr,&environ,newenviron,&unifyvar);
  1060.             break;
  1061.         case variable  : 
  1062.             unifyvariable(&list1,&list2,&varptr,&environ,newenviron,&unifyvar);
  1063.             break;
  1064.         case func      : 
  1065.             unifyfunc(&list1,&list2,&varptr,&environ,newenviron,&unifyvar);
  1066.             break;
  1067.         case consnode : 
  1068.             unifylists(&list1,&list2,&varptr,&environ,newenviron,&unifyvar);
  1069.             break;
  1070.         default : 
  1071.             fail(&environ,newenviron,&unifyvar);
  1072.             break;
  1073.             }
  1074.         }
  1075.     return(unifyvar);
  1076.     } /* unify */
  1077. makebinding(l1,l2,environ,newenviron,unifyvar)
  1078. register node * l1,*l2,**environ,**newenviron;
  1079. register boolean *unifyvar;
  1080. /* Bind a variable to the environment. Anonymous variables are not bound.
  1081. l1 points to the variable and l2 points to its binding. */
  1082.     {
  1083.     if (strcmp(stringval(l1),"") != 0)
  1084.         {
  1085.         *newenviron = cons(cons(l1,l2),*environ);
  1086.         }
  1087.     else 
  1088.         {
  1089.         *newenviron = *environ ;
  1090.         }
  1091.     *unifyvar = true ;
  1092.     } /* makebinding */
  1093. fail(environ,newenviron,unifyvar)
  1094. register node * *environ,**newenviron;
  1095. boolean *unifyvar;
  1096. /* Unification failed. */
  1097.     {
  1098.     *unifyvar = false ;
  1099.     *newenviron = *environ ;
  1100.     } /* fail */
  1101. unifyconstant(list1,list2,varptr,environ,newenviron,unifyvar)
  1102. register node **list1,**list2,**varptr,**environ,**newenviron;
  1103. boolean *unifyvar;
  1104. /* List1 contains a constant. Try to unify it with list2. The 4 cases
  1105. are:
  1106. list2 contains
  1107. constant - unify if constants match
  1108. variable - look up binding, if no current binding bind the
  1109. constant to the variable, otherwise unify list1
  1110. with the binding.
  1111. consnode,
  1112. func     - these can't be unified with a constant. A consnode
  1113. indicates an expression. */
  1114.     {
  1115.     if ((*list2) == NULL)
  1116.     nilconstant(list1);
  1117.     else
  1118.         {
  1119.         switch (tagvalue(*list2))
  1120.             {
  1121.         case constant  : 
  1122.             if (strcmp(stringval(*list1),stringval(*list2)) == 0)
  1123.                 {
  1124.                 *unifyvar = true ;
  1125.                 *newenviron = *environ ;
  1126.                 }
  1127.             else fail(environ,newenviron,unifyvar) ;
  1128.                 break;
  1129.             case variable  : 
  1130.                 *varptr = lookup(stringval(*list2),*environ) ;
  1131.                 if ((*varptr) == NULL)
  1132.                     makebinding((*list2),(*list1),environ,newenviron,unifyvar);
  1133.                 else 
  1134.                     *unifyvar = unify((*list1),(*varptr),*environ,newenviron) ;
  1135.                 break;
  1136.         case consnode:
  1137.         case func:      fail(environ,newenviron,unifyvar) ;
  1138.                         break;
  1139.         default :fail(environ,newenviron,unifyvar) ;
  1140.                 break;
  1141.             }
  1142.         }
  1143.     } /* unifyconstant */
  1144.  
  1145. nilconstant(list1,environ,newenviron,unifyvar)
  1146. register node **list1,**environ,**newenviron;
  1147. boolean *unifyvar;
  1148.     {
  1149.     if (strcmp(stringval(*list1),"[]") ==0)
  1150.         {
  1151.         *unifyvar = true ;
  1152.         *newenviron = *environ ;
  1153.         }
  1154.     else 
  1155.         fail(environ,newenviron,unifyvar) ;
  1156.     } /* nilconstant */
  1157. /* end scope unifyconstant */
  1158. unifyvariable(list1,list2,varptr,environ,newenviron,unifyvar)
  1159. register node * *list1,**list2,**varptr,**environ,**newenviron;
  1160. boolean *unifyvar;
  1161. /* The first list contained a variable, now try to unify that variable
  1162. with list2. If list2 is NULL, unify the varaible with '[]'. This
  1163. is for printing purposes only. */
  1164.     {
  1165.     *varptr = lookup(stringval(*list1),*environ) ;
  1166.     if ((*varptr) != NULL)
  1167.     *unifyvar = unify(*varptr,*list2,*environ,newenviron);
  1168.     else if (list2 == NULL)
  1169.         makebinding((*list1),allocstr(constant,"[]"),
  1170.         environ,newenviron,unifyvar);
  1171.     else if ((tagvalue(*list2) == constant)
  1172.             || (tagvalue(*list2) == variable)
  1173.             || (tagvalue(*list2) == func)
  1174.             || (tagvalue(*list2) == consnode)) 
  1175.         makebinding(*list1,*list2,environ,newenviron,unifyvar);
  1176.     else 
  1177.         fail(environ,newenviron,unifyvar) ;
  1178.     } /* unifyvariable */
  1179. unifyfunc(list1,list2,varptr,environ,newenviron,unifyvar)
  1180. register node * *list1,**list2,**varptr,**environ,**newenviron;
  1181. boolean *unifyvar;
  1182. /* List1 contains a functor. Try to unify it with list2. The 4 cases
  1183. are:
  1184. list2 contains
  1185. constant  - can't be unified.
  1186. variable  - look up binding, if no current binding bind the
  1187. functor to the variable, otherwise unify list1
  1188. with the binding.
  1189. consnode - fail
  1190. func      - if the functors match,  true to unify the component
  1191. lists (tail of the list) term by term. */
  1192.     {
  1193.     switch (tagvalue(*list2))
  1194.         {
  1195.     case constant  : fail(environ,newenviron,unifyvar) ;
  1196.         break;
  1197.     case variable  : 
  1198.             *varptr = lookup(stringval(*list2),*environ) ;
  1199.             if ((*varptr) == NULL)
  1200.                 makebinding(*list2,*list1,environ,newenviron,unifyvar);
  1201.             else 
  1202.                 *unifyvar = unify(*list1,*varptr,*environ,newenviron) ;
  1203.             break;
  1204.     case func      :
  1205.         if (strcmp(stringval(*list1),stringval(*list2)) ==0)
  1206.             {
  1207.             *unifyvar = true ;
  1208.             *newenviron = *environ ;
  1209.             }
  1210.         else fail(environ,newenviron,unifyvar) ;
  1211.         break;
  1212.     case consnode : fail(environ,newenviron,unifyvar) ;
  1213.         break;
  1214.     default : fail(environ,newenviron,unifyvar) ;
  1215.         break;
  1216.         }
  1217.     } /* unifyfunc */
  1218. unifylists(list1,list2,varptr,environ,newenviron,unifyvar)
  1219. register node * *list1,**list2,**varptr,**environ,**newenviron;
  1220. boolean *unifyvar;
  1221. /* List1 contains an expression. Try to unify it with list2. The 4 cases
  1222. are:
  1223. list2 contains
  1224. constant  - can't be unified.
  1225. variable  - look up binding, if no current binding bind the
  1226. functor to the variable, otherwise unify list1
  1227. with the binding.
  1228. consnode - If the heads can be unified,  unify the tails.
  1229. func      - fail */
  1230.     {
  1231.     switch (tagvalue(*list2))
  1232.         {
  1233.     case constant  : fail(environ,newenviron,unifyvar) ;
  1234.         break;
  1235.     case variable  : 
  1236.             *varptr = lookup(stringval(*list2),*environ) ;
  1237.             if ((*varptr) == NULL)
  1238.             makebinding(*list2,*list1,environ,newenviron,unifyvar);
  1239.             else 
  1240.                 *unifyvar = unify(*list1,*varptr,*environ,newenviron) ;
  1241.             break;
  1242.     case func      : fail(environ,newenviron,unifyvar) ;
  1243.             break;
  1244.     case consnode : 
  1245.         if (unify(head(*list1),head(*list2),*environ,newenviron))
  1246.             *unifyvar = unify(tail(*list1),tail(*list2),*environ,newenviron);
  1247.         break;
  1248.     default: fail(environ,newenviron,unifyvar) ;
  1249.         break;
  1250.         }
  1251.     } /* unifylists */
  1252. /* end scope unify */
  1253. /* end scope solve */
  1254. /* end scope query */
  1255. readnewfile(source)
  1256. register FILE *source;
  1257. /* Read source statements from a new file. When all done, close file
  1258. and continue reading from the old file. Files may be nested, but you
  1259. will run into trouble if you nest them deaper than 15 levels. This
  1260. is Turbo's default for open files. */
  1261.     {
  1262.     register FILE *newfile;
  1263.     char  oldline[132],oldsave[132];
  1264.     char  fname[80];
  1265.         
  1266.     if (token[0] == quote_char)
  1267.     delete(token,0,1) ;
  1268.     if (pos(".",token) == -1)
  1269.         {
  1270.         strcpy(fname,token);
  1271.         strcat(fname,".pro");
  1272.         }
  1273.     else 
  1274.         strcpy(fname , token) ;
  1275.     if ((newfile = fopen(fname,"r"))!= NULL)
  1276.         {
  1277.         strncpy(oldline, line, 132) ;
  1278.     /*    strncpy(oldsave, saved_line, 132) ; */
  1279.         line[0] = '\0' ;
  1280.         compile(newfile) ;
  1281.         fclose(newfile) ;
  1282.         strncpy(line, oldline, 132) ;
  1283.     /*    strncpy(saved_line, oldsave, 132) ; */
  1284.                 scan(source,token) ;
  1285.         if (token[0] != '.')
  1286.         error("'.' expected.",source) ;
  1287. }
  1288.     else 
  1289.         error("Unable to open ",source) ;
  1290.     } /* readnewfile */
  1291. doexit(source)
  1292. register FILE *source;
  1293. /* Exit the program. This really should be a built-in function and handled
  1294. in solve, but this does the trick. */
  1295.     {
  1296.     scan(source,token) ;
  1297.     if (token[0] != '.')
  1298.         error("'.' expected.",source);
  1299.     else 
  1300.         exit(0);
  1301.     } /* doexit */
  1302. /* end scope compile */
  1303. initialize()
  1304. /* Write a heading line and initialize the global variables */
  1305.     {
  1306.     printf("\n") ;
  1307.     printf(
  1308.     "Very Tiny Prolog - Version 1.1     [c] 1986 MicroExpert Systems\n") ;
  1309.     printf(
  1310.     "Modified from Pascal to C by Dennis Darland\n");
  1311.     printf ("\n");
  1312.     in_comment = false ;
  1313.     line[0] = '\0' ;
  1314.     data_base = NULL ;
  1315.     saved_list = NULL;
  1316.     } /* initialize */
  1317. mark(list)
  1318. register node *list;
  1319.    /* Mark the blocks on list as being in use. Since a node may be on several
  1320.       lists at one time, if it is already marked we don't continue processing
  1321.       the tail of the list. */
  1322.     {
  1323.     if (list != NULL)
  1324.         {
  1325.         if (!list->in_use)
  1326.             {
  1327.             list->in_use = true ;
  1328.               if (list->tag ==consnode)
  1329.                    {
  1330.                 mark(head(list)) ;
  1331.                 mark(tail(list)) ;
  1332.                 }
  1333.             }
  1334.        }
  1335.     }
  1336.  
  1337. unmarkmem()
  1338.    /* Go through memory from initialheap^ to HeapPtr^ and mark each node
  1339.       as not in use. The tricky part here is updating the pointer p to point
  1340.       to the next cell. */
  1341.    {
  1342.    register node  *p;
  1343.    p = chain_head;
  1344.    while (p)
  1345.            {
  1346.         p->in_use = false;
  1347.         p = p->chain_node_ptr.next_in_chain;
  1348.         }
  1349.     }
  1350. add_chain(p)
  1351. register node *p;
  1352.     {
  1353.     p->chain_node_ptr.next_in_chain = chain_head;
  1354.     chain_head = p;
  1355.     chain_cnt++;
  1356.     }            
  1357. freemem()
  1358.    /* Go through memory from initialheap^ to HeapPtr^ and mark each node
  1359.       as not in use. The tricky part here is updating the pointer p to point
  1360.       to the next cell. */
  1361.    {
  1362.    register node  *p;
  1363.    register node  *q;
  1364.    p = chain_head;
  1365.    q = NULL;
  1366.    while (p)
  1367.         {
  1368.         if( p->in_use == false);
  1369.             {
  1370.             if (q)
  1371.                 {
  1372.                 q->chain_node_ptr.next_in_chain = 
  1373.                 p->chain_node_ptr.next_in_chain;
  1374.                 free(p);
  1375.                 chain_cnt--;
  1376.                 }
  1377.             else
  1378.                 {
  1379.                 chain_head =     p->chain_node_ptr.next_in_chain;
  1380.                 free(p);
  1381.                 chain_cnt--;
  1382.                 }
  1383.             }
  1384.         q = p;
  1385.         p = p->chain_node_ptr.next_in_chain;
  1386.         }
  1387.     }
  1388.